perm filename COMBI.F4[PAG,LCS] blob sn#577465 filedate 1981-04-07 generic text, type T, neo UTF8
C****** COMBINES ONE-LINE MS FILES INTO 1 FILE WITH UP TO 8 LINES.
C******  LOAD WITH MSSIO.FAI[NEW,LCS]
	COMMON/STF/RSTFAC(0/7),RSTJ2 /POSI/STFF(0/7),JJ2,JPQ
	COMMON/XRN/RN(3000)/PTR/KWDS(350) /T/TOTAL,ADD,SPRED
	COMMON /PX/KPN(450) /Q/Q(3500),JQ,JK,STF,KQ,STFAC,JP
	INTEGER EXT1,EXT,EXT3

	TYPE 1
	TYPE 85
20	FORMAT(I)
1	FORMAT(' ALWAYS USE ONLY 5-LETTER NAMES.'/)
85	FORMAT('  TYPE TOP FILE NAME  '$)
2	FORMAT(A5,A1,A5)
3	FORMAT(' HOW MANY FILES?  '$)
CC3	FORMAT(' TYPE BOTTOM FILE NAME  '$)
5	FORMAT(' TYPE OUTPUT FILE NAME  '$)
	ACCEPT 2,NAM1,K,EXT1
	TYPE 3
CC	ACCEPT 2,NAME,K,EXT
	ACCEPT 20,K
	IF(K.EQ.0)K=7
	NAME=NAM1+(K-1)*2
	IF(EXT1.EQ.' ')EXT1='MS'
	EXT=EXT1
CC	IF(EXT.EQ.' ')EXT=EXT1
89	TYPE 5
	ACCEPT 2,NAM3,K,EXT3
	REREAD 87,STFF
	DO 86 K=0,4
	IF(STFF(K).NE.' '.AND.STFF(K).NE.'.')GO TO 86
	TYPE 1
	GO TO 89
86	CONTINUE
87	FORMAT(8A1)
	IF(EXT3.EQ.' ')EXT3=EXT1
	IF(LOOKX(NAM3,EXT3).GE.0)GO TO 21
	TYPE 88,NAM3,EXT3
	ACCEPT 2,L
	IF(L.NE.'Y')GO TO 89 
88	FORMAT(' WRITE OVER FILE ',A5,'.',A3,'????  '$)

21	IF(LOOKX(NAME,EXT).LT.0)GO TO 22
	NAME=NAME-2
C FIND LAST AVAILABLE NAME
	GO TO 21
22	STFAC=0
	STF=0
	SPRED=0
	ADD=0
	TOTAL=0
	JQ=0
	JK=0
	KQ=0
4	CALL INMUS(NAME,EXT,RN,KWDS,RSTFAC)
C ABOVE REPLACES GETEXT AND EXTIN.  NEW SAVE FORMAT
C*** 4	CALL GETEXT(NAME,EXT)
C  LP IS START OF RN ARRAY THIS TIME
	TYPE 7,NAME,EXT
7	FORMAT(1XA5,'.',A5)
C*** 	CALL EXTIN(RSTFAC,20)
C*** 	CALL EXTIN(KWDS,JJ2)
C*** 	CALL EXTIN(RN,JPQ)
 
	CALL PUTIT
C PUT RN INTO Q ARRAY, ETC.
CC	FAC=FAC+6.3
	NAME=NAME-2
	STF=STF+1
	JK=JK-1
	JQ=JQ-1
	SPRED=17.55
C 17.55 IS NORMAL DIST. (IN SCALE STEPS) BETWEEN STAVES.
	IF(NAME.GE.NAM1)GO TO 4
 
6	JJ2=JK+2
	JPQ=JQ+1
CCC	STF=STFAC*STF
CCC	Q(JP+8)=STF
	Q(JP+8)=TOTAL
	CALL PUTEXT(NAM3,EXT3)
	CALL EXTOUT(RSTFAC,20)
C*** 	CALL EXTOUT(KPN,JJ2)
C ABOVE NOT NEEDED WITH NEW SAVE FORMAT.
	CALL EXTOUT(Q,JPQ)
	CALL FINEXT
	JJ2=JJ2-2
CCC	STFAC=STF*2.54
CCC	TYPE 23,NAM3,EXT3,JJ2,JPQ,STF,STFAC
	STFAC=TOTAL*2.54
	TYPE 23,NAM3,EXT3,JJ2,JPQ,TOTAL,STFAC
23	FORMAT(//1XA5,'.',A5,I5,' ITEMS,',I6,' WDS,  C.',F5.2,' INCHES,'
	1,F7.2,' CM.')
	END

	SUBROUTINE PUTIT
	COMMON/STF/RSTFAC(0/7),RSTJ2 /POSI/STFF(0/7),JJ2,JPQ
	COMMON/XRN/RN(3000)/PTR/KWDS(300) /T/TOTAL,ADD,SPRED
	COMMON /PX/KPN(450) /Q/Q(3500),JQ,JK,STF,KQ,STFAC,JP
	DO 1 K=1,JJ2-1
	JK=JK+1
	J=KWDS(K)
	RN(J+2)=STF
	R=RN(J+1)
	IF(R.NE.8)GO TO 5
	IF(RN(J).LT.3)GO TO 1
C SKIP IF NO PARAMS AFTER P4
	R=RN(J+5)
	IF(R.EQ.0)R=1.
C STFAC IS INCHES TO NEXT STAFF.  ADD IS ACCUMULATED STEPS OF DISPLACEMENT.
	ADD=ADD+(23.8*STFAC-SPRED)/R
	RN(J+4)=ADD
CCC	RN(J+4)=6.25*STF*STFAC/R
CCC	RN(J+4)=(STF*STFAC*23.8-17.55*STF)/R
C ASSUMES THERE IS A SOMETHING IN P5 AND P8
 	IF(RN(J).LT.6)GO TO 8
	STFAC=RN(J+8)
	TOTAL=TOTAL+STFAC
	RN(J+8)=0
8	IF(JQ.EQ.0)JP=J
C SAVE POINTER TO FIRST STAFF. PUT IN INCHES AT END
	GO TO 1
5	IF(R.NE.2)GO TO 1
	IF(RN(J+9).GE.0)GO TO 1
C ONLY CHANGE POSITION OF REST IF P9=-1
	IF(RN(J).LT.7)GO TO 1
	JJ=K+1
6	JJJ=KWDS(JJ)
	IF(RN(JJJ+1).EQ.4)GO TO 7
C LOOK FOR BAR LINE
	JJ=JJ+1
	IF(JJ.LT.JJ2)GO TO 6
	GO TO 1
7	RN(J+9)=RN(J+3)+(RN(JJJ+3)-RN(J+3))/2.0-4.0*RSTFAC(0)
1	KPN(JK)=J+KQ
	KQ=KQ+KWDS(JJ2-1)-1
3	DO 2 K=1,JPQ
	JQ=JQ+1
2	Q(JQ)=RN(K)
4	END